home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d12
/
vol6n20.arc
/
PROFIL.ARC
/
SCREEN.PRF
< prev
Wrap
Text File
|
1987-10-31
|
8KB
|
185 lines
{ These procedures handle the screen display. Attribute, EGAInstalled, }
{ GetVideoMode, and FastWrite are by Brian Foley, and are available in }
{ DL4 as FASTWR.PAS. }
const
BlankLine = ' ' ;
var
BaseOfScreen : integer ;
WaitForRetrace : boolean ;
TextAttr,
EmphAttr : byte ;
function Attribute(Foreground, Background : Byte) : Byte;
{-Translates foreground and background colors into video attributes.
"And 127" masks out the blink bit. Add 128 to the result to set it.}
begin
Attribute := ((Background Shl 4) + Foreground) And 127;
end;
function EgaInstalled : Boolean;
{-Test for presence of the EGA. I have little idea how this works, but
it does.}
begin
Inline(
$B8/$00/$12 { MOV AX,$1200}
/$BB/$10/$00 { MOV BX,$10}
/$B9/$FF/$FF { MOV CX,$FFFF}
/$CD/$10 { INT $10}
/$31/$C0 { XOR AX,AX}
/$81/$F9/$FF/$FF { CMP CX,$FFFF}
/$74/$01 { JE DONE}
/$40 { INC AX}
/$88/$46/$04 {DONE: MOV [BP+$04],AL}
);
end;
procedure GetVideoMode;
{-Video mode of 7 indicates mono display; all other modes are for color
displays. This routine MUST be called before any of the screen writing
routines are used!}
var
Mode : Integer;
begin
Inline(
$B4/$0F {MOV AH,$F}
/$CD/$10 {INT $10}
/$30/$E4 {XOR AH,AH}
/$89/$46/<Mode {MOV [BP+<Mode],AX}
);
IF Mode = 7 then BaseOfScreen := $B000 { Mono }
else BaseOfScreen := $B800; { Color }
WaitForRetrace := (BaseOfScreen = $B800) And Not EgaInstalled;
{ If WaitForRetrace is True, you may want to allow the user to decide
whether to forego snow prevention in favor of faster screen updates.
*VERY IMPORTANT* WaitForRetrace MUST be false if BaseOfScreen = $B000. }
end;
procedure FastWrite( St : String80; Row, Col, Attr : Byte );
{-Write St directly to video memory, without snow.}
begin
Inline(
$1E { PUSH DS ;Save DS}
/$31/$C0 { XOR AX,AX ;AX = 0}
/$88/$C1 { MOV CL,AL ;CL = 0}
/$8A/$AE/>Row { MOV CH,[BP+>Row] ;CX = Row * 256}
/$FE/$CD { DEC CH ;Row to 0..24 range}
/$D1/$E9 { SHR CX,1 ;CX = Row * 128}
/$89/$CF { MOV DI,CX ;Store in DI}
/$D1/$EF { SHR DI,1 ;DI = Row * 64}
/$D1/$EF { SHR DI,1 ;DI = Row * 32}
/$01/$CF { ADD DI,CX ;DI = (Row * 160)}
/$8B/$8E/>Col { MOV CX,[BP+>Col] ;CX = Column}
/$49 { DEC CX ;Col to 0..79 range}
/$D1/$E1 { SHL CX,1 ;Account for attribute bytes}
/$01/$CF { ADD DI,CX ;DI = (Row * 160) + (Col * 2)}
/$8E/$06/>BaseOfScreen { MOV ES,[>BaseOfScreen] ;ES:DI points to Base:Row,Col}
/$8A/$0E/>WaitForRetrace{ MOV CL,[>WaitForRetrace] ;Grab this before changing DS}
/$8C/$D2 { MOV DX,SS ;Move SS...}
/$8E/$DA { MOV DS,DX ; into DS}
/$8D/$B6/>St { LEA SI,[BP+>St] ;DS:SI points to St[0]}
/$FC { CLD ;Set direction to forward}
/$AC { LODSB ;AX = Length(St); DS:SI -> St[1]}
/$91 { XCHG AX,CX ;CX = Length; AL = Wait}
/$E3/$29 { JCXZ Exit ;If string empty, Exit}
/$8A/$A6/>Attr { MOV AH,[BP+>Attr] ;AH = Attribute}
/$D0/$D8 { RCR AL,1 ;If WaitForRetrace is False...}
/$73/$1D { JNC NoWait ; use NoWait routine}
/$BA/$DA/$03 { MOV DX,$03DA ;Point DX to CGA status port}
/$AC {Next: LODSB ;Load next character into AL}
{ ; AH already has Attr}
/$89/$C3 { MOV BX,AX ;Store video word in BX}
/$FA { CLI ;No interrupts now}
/$EC {WaitNoH: IN AL,DX ;Get 6845 status}
/$A8/$08 { TEST AL,8 ;Check for vertical retrace}
/$75/$09 { JNZ Store ; In progress? go}
/$D0/$D8 { RCR AL,1 ;Else, wait for end of}
/$72/$F7 { JC WaitNoH ; horizontal retrace}
/$EC {WaitH: IN AL,DX ;Get 6845 status again}
/$D0/$D8 { RCR AL,1 ;Wait for horizontal}
/$73/$FB { JNC WaitH ; retrace}
/$89/$D8 {Store: MOV AX,BX ;Move word back to AX...}
/$AB { STOSW ; and then to screen}
/$FB { STI ;Allow interrupts}
/$E2/$E8 { LOOP Next ;Get next character}
/$EB/$04 { JMP SHORT Exit ;Done}
/$AC {NoWait: LODSB ;Load next character into AL}
{ ; AH already has Attr}
/$AB { STOSW ;Move video word into place}
/$E2/$FC { LOOP NoWait ;Get next character}
/$1F {Exit: POP DS ;Restore DS}
);
end;
procedure HideCursor ; { hide the DOS cursor by putting it below the screen }
var
Registers : record
case integer of
1 : ( ax,bx,cx,dx,bp,si,di,ds,es,flags : integer ) ;
2 : ( al,ah,bl,bh,cl,ch,dl,dh : byte ) ;
end;
begin
Registers.dh := 25 ; { row to move cursor to }
Registers.dl := 0 ; { column to move cursor to }
Registers.bh := 0 ; { screen page }
Registers.ah := 2 ; { function identifier }
intr( $10, Registers ) ; { do it }
end; { procedure HideCursor }
procedure ClearScreen ;
var
Line : integer ;
begin
for Line := 1 to 25 do
FastWrite( BlankLine, Line, 1, TextAttr ) ;
HideCursor ;
end; { procedure ClearScreen }
procedure SetupScreen ;
var
ch : char ;
begin
GetVideoMode ;
{ Take care of snow elimination }
if WaitForRetrace then
begin
Write( 'Does your screen generate snow? ' ) ;
Read( KBD, ch ) ;
WaitForRetrace := (UpCase(ch) <> 'N' ) ;
end;
{ Set display attributes }
if BaseOfScreen = $B000 then
begin
TextAttr := Attribute( White, Black ) ;
EmphAttr := Attribute( Black, White ) ;
end
else
begin
TextAttr := Attribute( Yellow, Blue ) ;
EmphAttr := Attribute( White, Blue ) ;
GraphBackground( Blue ) ;
end; { if }
ClearScreen ;
end; { procedure SetupScreen }
procedure DrawProfileScreen ;
begin
ClearScreen ;
FastWrite( 'Execution Profiler', 1, 31, EmphAttr ) ;
FastWrite( Copyright, 2, 23, EmphAttr ) ;
end; { procedure DrawProfileScreen }
procedure DrawWarningScreen ;
begin
ClearScreen ;
FastWrite( 'WARNING:', 5, 36, EmphAttr ) ;
FastWrite( 'This program only works on the IBM PC and close compatibles.', 7, 10, EmphAttr ) ;
FastWrite( 'If you do not have the right machine, this program might', 8, 12, Emphattr ) ;
FastWrite( 'crash your system.', 9, 31, Emphattr ) ;
FastWrite( 'Do you wish to continue? (y or n)', 11, 23, TextAttr ) ;
GotoXY( 57, 11 );
end;